home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / calc202a.lha / calc-2.02a / calc-prog.el < prev    next >
Lisp/Scheme  |  1993-06-01  |  67KB  |  2,364 lines
  1. ;; Calculator for GNU Emacs, part II [calc-prog.el]
  2. ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
  3. ;; Written by Dave Gillespie, daveg@synaptics.com.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22.  
  23.  
  24. ;; This file is autoloaded from calc-ext.el.
  25. (require 'calc-ext)
  26.  
  27. (require 'calc-macs)
  28.  
  29. (defun calc-Need-calc-prog () nil)
  30.  
  31.  
  32. (defun calc-equal-to (arg)
  33.   (interactive "P")
  34.   (calc-wrapper
  35.    (if (and (integerp arg) (> arg 2))
  36.        (calc-enter-result arg "eq" (cons 'calcFunc-eq (calc-top-list-n arg)))
  37.      (calc-binary-op "eq" 'calcFunc-eq arg)))
  38. )
  39.  
  40. (defun calc-remove-equal (arg)
  41.   (interactive "P")
  42.   (calc-wrapper
  43.    (calc-unary-op "rmeq" 'calcFunc-rmeq arg))
  44. )
  45.  
  46. (defun calc-not-equal-to (arg)
  47.   (interactive "P")
  48.   (calc-wrapper
  49.    (if (and (integerp arg) (> arg 2))
  50.        (calc-enter-result arg "neq" (cons 'calcFunc-neq (calc-top-list-n arg)))
  51.      (calc-binary-op "neq" 'calcFunc-neq arg)))
  52. )
  53.  
  54. (defun calc-less-than (arg)
  55.   (interactive "P")
  56.   (calc-wrapper
  57.    (calc-binary-op "lt" 'calcFunc-lt arg))
  58. )
  59.  
  60. (defun calc-greater-than (arg)
  61.   (interactive "P")
  62.   (calc-wrapper
  63.    (calc-binary-op "gt" 'calcFunc-gt arg))
  64. )
  65.  
  66. (defun calc-less-equal (arg)
  67.   (interactive "P")
  68.   (calc-wrapper
  69.    (calc-binary-op "leq" 'calcFunc-leq arg))
  70. )
  71.  
  72. (defun calc-greater-equal (arg)
  73.   (interactive "P")
  74.   (calc-wrapper
  75.    (calc-binary-op "geq" 'calcFunc-geq arg))
  76. )
  77.  
  78. (defun calc-in-set (arg)
  79.   (interactive "P")
  80.   (calc-wrapper
  81.    (calc-binary-op "in" 'calcFunc-in arg))
  82. )
  83.  
  84. (defun calc-logical-and (arg)
  85.   (interactive "P")
  86.   (calc-wrapper
  87.    (calc-binary-op "land" 'calcFunc-land arg 1))
  88. )
  89.  
  90. (defun calc-logical-or (arg)
  91.   (interactive "P")
  92.   (calc-wrapper
  93.    (calc-binary-op "lor" 'calcFunc-lor arg 0))
  94. )
  95.  
  96. (defun calc-logical-not (arg)
  97.   (interactive "P")
  98.   (calc-wrapper
  99.    (calc-unary-op "lnot" 'calcFunc-lnot arg))
  100. )
  101.  
  102. (defun calc-logical-if ()
  103.   (interactive)
  104.   (calc-wrapper
  105.    (calc-enter-result 3 "if" (cons 'calcFunc-if (calc-top-list-n 3))))
  106. )
  107.  
  108.  
  109.  
  110.  
  111.  
  112. (defun calc-timing (n)
  113.   (interactive "P")
  114.   (calc-wrapper
  115.    (calc-change-mode 'calc-timing n nil t)
  116.    (message (if calc-timing
  117.         "Reporting timing of slow commands in Trail."
  118.           "Not reporting timing of commands.")))
  119. )
  120.  
  121. (defun calc-pass-errors ()
  122.   (interactive)
  123.   ;; The following two cases are for the new, optimizing byte compiler
  124.   ;; or the standard 18.57 byte compiler, respectively.
  125.   (condition-case err
  126.       (let ((place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 15)))
  127.     (or (memq (car-safe (car-safe place)) '(error xxxerror))
  128.         (setq place (aref (nth 2 (nth 2 (symbol-function 'calc-do))) 27)))
  129.     (or (memq (car (car place)) '(error xxxerror))
  130.         (error "foo"))
  131.     (setcar (car place) 'xxxerror))
  132.     (error (error "The calc-do function has been modified; unable to patch.")))
  133. )
  134.  
  135. (defun calc-user-define ()
  136.   (interactive)
  137.   (message "Define user key: z-")
  138.   (let ((key (read-char)))
  139.     (if (= (calc-user-function-classify key) 0)
  140.     (error "Can't redefine \"?\" key"))
  141.     (let ((func (intern (completing-read (concat "Set key z "
  142.                          (char-to-string key)
  143.                          " to command: ")
  144.                      obarray
  145.                      'commandp
  146.                      t
  147.                      "calc-"))))
  148.       (let* ((kmap (calc-user-key-map))
  149.          (old (assq key kmap)))
  150.     (if old
  151.         (setcdr old func)
  152.       (setcdr kmap (cons (cons key func) (cdr kmap)))))))
  153. )
  154.  
  155. (defun calc-user-undefine ()
  156.   (interactive)
  157.   (message "Undefine user key: z-")
  158.   (let ((key (read-char)))
  159.     (if (= (calc-user-function-classify key) 0)
  160.     (error "Can't undefine \"?\" key"))
  161.     (let* ((kmap (calc-user-key-map)))
  162.       (delq (or (assq key kmap)
  163.         (assq (upcase key) kmap)
  164.         (assq (downcase key) kmap)
  165.         (error "No such user key is defined"))
  166.         kmap)))
  167. )
  168.  
  169. (defun calc-user-define-formula ()
  170.   (interactive)
  171.   (calc-wrapper
  172.    (let* ((form (calc-top 1))
  173.       (arglist nil)
  174.       (is-lambda (and (eq (car-safe form) 'calcFunc-lambda)
  175.               (>= (length form) 2)))
  176.       odef key keyname cmd cmd-base func alist is-symb)
  177.      (if is-lambda
  178.      (setq arglist (mapcar (function (lambda (x) (nth 1 x)))
  179.                    (nreverse (cdr (reverse (cdr form)))))
  180.            form (nth (1- (length form)) form))
  181.        (calc-default-formula-arglist form)
  182.        (setq arglist (sort arglist 'string-lessp)))
  183.      (message "Define user key: z-")
  184.      (setq key (read-char))
  185.      (if (= (calc-user-function-classify key) 0)
  186.      (error "Can't redefine \"?\" key"))
  187.      (setq key (and (not (memq key '(13 32))) key)
  188.        keyname (and key
  189.             (if (or (and (<= ?0 key) (<= key ?9))
  190.                 (and (<= ?a key) (<= key ?z))
  191.                 (and (<= ?A key) (<= key ?Z)))
  192.                 (char-to-string key)
  193.               (format "%03d" key)))
  194.        odef (assq key (calc-user-key-map)))
  195.      (while
  196.      (progn
  197.        (setq cmd (completing-read "Define M-x command name: "
  198.                       obarray 'commandp nil
  199.                       (if (and odef (symbolp (cdr odef)))
  200.                       (symbol-name (cdr odef))
  201.                     "calc-"))
  202.          cmd-base (and (string-match "\\`calc-\\(.+\\)\\'" cmd)
  203.                    (math-match-substring cmd 1))
  204.          cmd (and (not (or (string-equal cmd "")
  205.                    (string-equal cmd "calc-")))
  206.               (intern cmd)))
  207.        (and cmd
  208.         (fboundp cmd)
  209.         odef
  210.         (not
  211.          (y-or-n-p
  212.           (if (get cmd 'calc-user-defn)
  213.               (concat "Replace previous definition for "
  214.                   (symbol-name cmd) "? ")
  215.             "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
  216.      (if (and key (not cmd))
  217.      (setq cmd (intern (concat "calc-User-" keyname))))
  218.      (while
  219.      (progn
  220.        (setq func (completing-read "Define algebraic function name: "
  221.                        obarray 'fboundp nil
  222.                        (concat "calcFunc-"
  223.                            (if cmd-base
  224.                            (if (string-match
  225.                             "\\`User-.+" cmd-base)
  226.                                (concat
  227.                             "User"
  228.                             (substring cmd-base 5))
  229.                              cmd-base)
  230.                          "")))
  231.          func (and (not (or (string-equal func "")
  232.                     (string-equal func "calcFunc-")))
  233.                (intern func)))
  234.        (and func
  235.         (fboundp func)
  236.         (not (fboundp cmd))
  237.         odef
  238.         (not
  239.          (y-or-n-p
  240.           (if (get func 'calc-user-defn)
  241.               (concat "Replace previous definition for "
  242.                   (symbol-name func) "? ")
  243.             "That name conflicts with a built-in Emacs function.  Replace this function? "))))))
  244.      (if (not func)
  245.      (setq func (intern (concat "calcFunc-User"
  246.                     (or keyname
  247.                     (and cmd (symbol-name cmd))
  248.                     (format "%05d" (% (random) 10000)))))))
  249.      (if is-lambda
  250.      (setq alist arglist)
  251.        (while
  252.        (progn
  253.          (setq alist (read-from-minibuffer "Function argument list: "
  254.                            (if arglist
  255.                            (prin1-to-string arglist)
  256.                          "()")
  257.                            minibuffer-local-map
  258.                            t))
  259.          (and (not (calc-subsetp alist arglist))
  260.           (not (y-or-n-p
  261.             "Okay for arguments that don't appear in formula to be ignored? "))))))
  262.      (setq is-symb (and alist
  263.             func
  264.             (y-or-n-p
  265.              "Leave it symbolic for non-constant arguments? ")))
  266.      (setq alist (mapcar (function (lambda (x)
  267.                      (or (cdr (assq x '((nil . arg-nil)
  268.                             (t . arg-t))))
  269.                      x))) alist))
  270.      (if cmd
  271.      (progn
  272.        (calc-need-macros)
  273.        (fset cmd
  274.          (list 'lambda
  275.                '()
  276.                '(interactive)
  277.                (list 'calc-wrapper
  278.                  (list 'calc-enter-result
  279.                    (length alist)
  280.                    (let ((name (symbol-name (or func cmd))))
  281.                      (and (string-match
  282.                        "\\([^-][^-]?[^-]?[^-]?\\)[^-]*\\'"
  283.                        name)
  284.                       (math-match-substring name 1)))
  285.                    (list 'cons
  286.                      (list 'quote func)
  287.                      (list 'calc-top-list-n
  288.                            (length alist)))))))
  289.        (put cmd 'calc-user-defn t)))
  290.      (let ((body (list 'math-normalize (calc-fix-user-formula form))))
  291.        (fset func
  292.          (append
  293.           (list 'lambda alist)
  294.           (and is-symb
  295.            (mapcar (function (lambda (v)
  296.                        (list 'math-check-const v t)))
  297.                alist))
  298.           (list body))))
  299.      (put func 'calc-user-defn form)
  300.      (setq math-integral-cache-state nil)
  301.      (if key
  302.      (let* ((kmap (calc-user-key-map))
  303.         (old (assq key kmap)))
  304.        (if old
  305.            (setcdr old cmd)
  306.          (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
  307.    (message ""))
  308. )
  309.  
  310. (defun calc-default-formula-arglist (form)
  311.   (if (consp form)
  312.       (if (eq (car form) 'var)
  313.       (if (or (memq (nth 1 form) arglist)
  314.           (math-const-var form))
  315.           ()
  316.         (setq arglist (cons (nth 1 form) arglist)))
  317.     (calc-default-formula-arglist-step (cdr form))))
  318. )
  319.  
  320. (defun calc-default-formula-arglist-step (l)
  321.   (and l
  322.        (progn
  323.      (calc-default-formula-arglist (car l))
  324.      (calc-default-formula-arglist-step (cdr l))))
  325. )
  326.  
  327. (defun calc-subsetp (a b)
  328.   (or (null a)
  329.       (and (memq (car a) b)
  330.        (calc-subsetp (cdr a) b)))
  331. )
  332.  
  333. (defun calc-fix-user-formula (f)
  334.   (if (consp f)
  335.       (let (temp)
  336.     (cond ((and (eq (car f) 'var)
  337.             (memq (setq temp (or (cdr (assq (nth 1 f) '((nil . arg-nil)
  338.                                 (t . arg-t))))
  339.                      (nth 1 f)))
  340.               alist))
  341.            temp)
  342.           ((or (math-constp f) (eq (car f) 'var))
  343.            (list 'quote f))
  344.           ((and (eq (car f) 'calcFunc-eval)
  345.             (= (length f) 2))
  346.            (list 'let '((calc-simplify-mode nil))
  347.              (list 'math-normalize (calc-fix-user-formula (nth 1 f)))))
  348.           ((and (eq (car f) 'calcFunc-evalsimp)
  349.             (= (length f) 2))
  350.            (list 'math-simplify (calc-fix-user-formula (nth 1 f))))
  351.           ((and (eq (car f) 'calcFunc-evalextsimp)
  352.             (= (length f) 2))
  353.            (list 'math-simplify-extended
  354.              (calc-fix-user-formula (nth 1 f))))
  355.           (t
  356.            (cons 'list
  357.              (cons (list 'quote (car f))
  358.                (mapcar 'calc-fix-user-formula (cdr f)))))))
  359.     f)
  360. )
  361.  
  362. (defun calc-user-define-composition ()
  363.   (interactive)
  364.   (calc-wrapper
  365.    (if (eq calc-language 'unform)
  366.        (error "Can't define formats for unformatted mode"))
  367.    (let* ((comp (calc-top 1))
  368.       (func (intern (completing-read "Define format for which function: "
  369.                      obarray 'fboundp nil "calcFunc-")))
  370.       (comps (get func 'math-compose-forms))
  371.       entry entry2
  372.       (arglist nil)
  373.       (alist nil))
  374.      (if (math-zerop comp)
  375.      (if (setq entry (assq calc-language comps))
  376.          (put func 'math-compose-forms (delq entry comps)))
  377.        (calc-default-formula-arglist comp)
  378.        (setq arglist (sort arglist 'string-lessp))
  379.        (while
  380.        (progn
  381.          (setq alist (read-from-minibuffer "Composition argument list: "
  382.                            (if arglist
  383.                            (prin1-to-string arglist)
  384.                          "()")
  385.                            minibuffer-local-map
  386.                            t))
  387.          (and (not (calc-subsetp alist arglist))
  388.           (y-or-n-p
  389.            "Okay for arguments that don't appear in formula to be invisible? "))))
  390.        (or (setq entry (assq calc-language comps))
  391.        (put func 'math-compose-forms
  392.         (cons (setq entry (list calc-language)) comps)))
  393.        (or (setq entry2 (assq (length alist) (cdr entry)))
  394.        (setcdr entry
  395.            (cons (setq entry2 (list (length alist))) (cdr entry))))
  396.        (setcdr entry2 (list 'lambda alist (calc-fix-user-formula comp))))
  397.      (calc-pop-stack 1)
  398.      (calc-do-refresh)))
  399. )
  400.  
  401.  
  402. (defun calc-user-define-kbd-macro (arg)
  403.   (interactive "P")
  404.   (or last-kbd-macro
  405.       (error "No keyboard macro defined"))
  406.   (message "Define last kbd macro on user key: z-")
  407.   (let ((key (read-char)))
  408.     (if (= (calc-user-function-classify key) 0)
  409.     (error "Can't redefine \"?\" key"))
  410.     (let ((cmd (intern (completing-read "Full name for new command: "
  411.                     obarray
  412.                     'commandp
  413.                     nil
  414.                     (concat "calc-User-"
  415.                         (if (or (and (>= key ?a)
  416.                                  (<= key ?z))
  417.                             (and (>= key ?A)
  418.                                  (<= key ?Z))
  419.                             (and (>= key ?0)
  420.                                  (<= key ?9)))
  421.                             (char-to-string key)
  422.                           (format "%03d" key)))))))
  423.       (and (fboundp cmd)
  424.        (not (let ((f (symbol-function cmd)))
  425.           (or (stringp f)
  426.               (and (consp f)
  427.                (eq (car-safe (nth 3 f))
  428.                    'calc-execute-kbd-macro)))))
  429.        (error "Function %s is already defined and not a keyboard macro"
  430.           cmd))
  431.       (put cmd 'calc-user-defn t)
  432.       (fset cmd (if (< (prefix-numeric-value arg) 0)
  433.             last-kbd-macro
  434.           (list 'lambda
  435.             '(arg)
  436.             '(interactive "P")
  437.             (list 'calc-execute-kbd-macro
  438.                   (vector (key-description last-kbd-macro)
  439.                       last-kbd-macro)
  440.                   'arg
  441.                   (format "z%c" key)))))
  442.       (let* ((kmap (calc-user-key-map))
  443.          (old (assq key kmap)))
  444.     (if old
  445.         (setcdr old cmd)
  446.       (setcdr kmap (cons (cons key cmd) (cdr kmap)))))))
  447. )
  448.  
  449.  
  450. (defun calc-edit-user-syntax ()
  451.   (interactive)
  452.   (calc-wrapper
  453.    (let ((lang calc-language))
  454.      (calc-edit-mode (list 'calc-finish-user-syntax-edit (list 'quote lang))
  455.              t
  456.              (format "Editing %s-Mode Syntax Table"
  457.                  (cond ((null lang) "Normal")
  458.                    ((eq lang 'tex) "TeX")
  459.                    (t (capitalize (symbol-name lang))))))
  460.      (calc-write-parse-table (cdr (assq lang calc-user-parse-tables))
  461.                  lang)))
  462.   (calc-show-edit-buffer)
  463. )
  464.  
  465. (defun calc-finish-user-syntax-edit (lang)
  466.   (let ((tab (calc-read-parse-table calc-original-buffer lang))
  467.     (entry (assq lang calc-user-parse-tables)))
  468.     (if tab
  469.     (setcdr (or entry
  470.             (car (setq calc-user-parse-tables
  471.                    (cons (list lang) calc-user-parse-tables))))
  472.         tab)
  473.       (if entry
  474.       (setq calc-user-parse-tables
  475.         (delq entry calc-user-parse-tables)))))
  476.   (switch-to-buffer calc-original-buffer)
  477. )
  478.  
  479. (defun calc-write-parse-table (tab calc-lang)
  480.   (let ((p tab))
  481.     (while p
  482.       (calc-write-parse-table-part (car (car p)))
  483.       (insert ":= "
  484.           (let ((math-format-hash-args t))
  485.         (math-format-flat-expr (cdr (car p)) 0))
  486.           "\n")
  487.       (setq p (cdr p))))
  488. )
  489.  
  490. (defun calc-write-parse-table-part (p)
  491.   (while p
  492.     (cond ((stringp (car p))
  493.        (let ((s (car p)))
  494.          (if (and (string-match "\\`\\\\dots\\>" s)
  495.               (not (eq calc-lang 'tex)))
  496.          (setq s (concat ".." (substring s 5))))
  497.          (if (or (and (string-match
  498.                "[a-zA-Z0-9\"{}]\\|\\`:=\\'\\|\\`#\\|\\`%%" s)
  499.               (string-match "[^a-zA-Z0-9\\]" s))
  500.              (and (assoc s '((")") ("]") (">")))
  501.               (not (cdr p))))
  502.          (insert (prin1-to-string s) " ")
  503.            (insert s " "))))
  504.       ((integerp (car p))
  505.        (insert "#")
  506.        (or (= (car p) 0)
  507.            (insert "/" (int-to-string (car p))))
  508.        (insert " "))
  509.       ((and (eq (car (car p)) '\?) (equal (car (nth 2 (car p))) "$$"))
  510.        (insert (car (nth 1 (car p))) " "))
  511.       (t
  512.        (insert "{ ")
  513.        (calc-write-parse-table-part (nth 1 (car p)))
  514.        (insert "}" (symbol-name (car (car p))))
  515.        (if (nth 2 (car p))
  516.            (calc-write-parse-table-part (list (car (nth 2 (car p)))))
  517.          (insert " "))))
  518.     (setq p (cdr p)))
  519. )
  520.  
  521. (defun calc-read-parse-table (calc-buf calc-lang)
  522.   (let ((tab nil))
  523.     (while (progn
  524.          (skip-chars-forward "\n\t ")
  525.          (not (eobp)))
  526.       (if (looking-at "%%")
  527.       (end-of-line)
  528.     (let ((pt (point))
  529.           (p (calc-read-parse-table-part ":=[\n\t ]+" ":=")))
  530.       (or (stringp (car p))
  531.           (and (integerp (car p))
  532.            (stringp (nth 1 p)))
  533.           (progn
  534.         (goto-char pt)
  535.         (error "Malformed syntax rule")))
  536.       (let ((pos (point)))
  537.         (end-of-line)
  538.         (let* ((str (buffer-substring pos (point)))
  539.            (exp (save-excursion
  540.               (set-buffer calc-buf)
  541.               (let ((calc-user-parse-tables nil)
  542.                 (calc-language nil)
  543.                 (math-expr-opers math-standard-opers)
  544.                 (calc-hashes-used 0))
  545.                 (math-read-expr
  546.                  (if (string-match ",[ \t]*\\'" str)
  547.                  (substring str 0 (match-beginning 0))
  548.                    str))))))
  549.           (if (eq (car-safe exp) 'error)
  550.           (progn
  551.             (goto-char (+ pos (nth 1 exp)))
  552.             (error (nth 2 exp))))
  553.           (setq tab (nconc tab (list (cons p exp)))))))))
  554.     tab)
  555. )
  556.  
  557. (defun calc-fix-token-name (name &optional unquoted)
  558.   (cond ((string-match "\\`\\.\\." name)
  559.      (concat "\\dots" (substring name 2)))
  560.     ((and (equal name "{") (memq calc-lang '(tex eqn)))
  561.      "(")
  562.     ((and (equal name "}") (memq calc-lang '(tex eqn)))
  563.      ")")
  564.     ((and (equal name "&") (eq calc-lang 'tex))
  565.      ",")
  566.     ((equal name "#")
  567.      (search-backward "#")
  568.      (error "Token '#' is reserved"))
  569.     ((and unquoted (string-match "#" name))
  570.      (error "Tokens containing '#' must be quoted"))
  571.     ((not (string-match "[^ ]" name))
  572.      (search-backward "\"" nil t)
  573.      (error "Blank tokens are not allowed"))
  574.     (t name))
  575. )
  576.  
  577. (defun calc-read-parse-table-part (term eterm)
  578.   (let ((part nil)
  579.     (quoted nil))
  580.     (while (progn
  581.          (skip-chars-forward "\n\t ")
  582.          (if (eobp) (error "Expected '%s'" eterm))
  583.          (not (looking-at term)))
  584.       (cond ((looking-at "%%")
  585.          (end-of-line))
  586.         ((looking-at "{[\n\t ]")
  587.          (forward-char 2)
  588.          (let ((p (calc-read-parse-table-part "}" "}")))
  589.            (or (looking-at "[+*?]")
  590.            (error "Expected '+', '*', or '?'"))
  591.            (let ((sym (intern (buffer-substring (point) (1+ (point))))))
  592.          (forward-char 1)
  593.          (looking-at "[^\n\t ]*")
  594.          (let ((sep (buffer-substring (point) (match-end 0))))
  595.            (goto-char (match-end 0))
  596.            (and (eq sym '\?) (> (length sep) 0)
  597.             (not (equal sep "$")) (not (equal sep "."))
  598.             (error "Separator not allowed with { ... }?"))
  599.            (if (string-match "\\`\"" sep)
  600.                (setq sep (read-from-string sep)))
  601.            (setq sep (calc-fix-token-name sep))
  602.            (setq part (nconc part
  603.                      (list (list sym p
  604.                          (and (> (length sep) 0)
  605.                               (cons sep p))))))))))
  606.         ((looking-at "}")
  607.          (error "Too many }'s"))
  608.         ((looking-at "\"")
  609.          (setq quoted (calc-fix-token-name (read (current-buffer)))
  610.            part (nconc part (list quoted))))
  611.         ((looking-at "#\\(\\(/[0-9]+\\)?\\)[\n\t ]")
  612.          (setq part (nconc part (list (if (= (match-beginning 1)
  613.                          (match-end 1))
  614.                           0
  615.                         (string-to-int
  616.                          (buffer-substring
  617.                           (1+ (match-beginning 1))
  618.                           (match-end 1)))))))
  619.          (goto-char (match-end 0)))
  620.         ((looking-at ":=[\n\t ]")
  621.          (error "Misplaced ':='"))
  622.         (t
  623.          (looking-at "[^\n\t ]*")
  624.          (let ((end (match-end 0)))
  625.            (setq part (nconc part (list (calc-fix-token-name
  626.                          (buffer-substring
  627.                           (point) end) t))))
  628.            (goto-char end)))))
  629.     (goto-char (match-end 0))
  630.     (let ((len (length part)))
  631.       (while (and (> len 1)
  632.           (let ((last (nthcdr (setq len (1- len)) part)))
  633.             (and (assoc (car last) '((")") ("]") (">")))
  634.              (not (eq (car last) quoted))
  635.              (setcar last
  636.                  (list '\? (list (car last)) '("$$"))))))))
  637.     part)
  638. )
  639.  
  640.  
  641. (defun calc-user-define-invocation ()
  642.   (interactive)
  643.   (or last-kbd-macro
  644.       (error "No keyboard macro defined"))
  645.   (setq calc-invocation-macro last-kbd-macro)
  646.   (message "Use `M-# Z' to invoke this macro")
  647. )
  648.  
  649.  
  650. (defun calc-user-define-edit (prefix)
  651.   (interactive "P")  ; but no calc-wrapper!
  652.   (message "Edit definition of command: z-")
  653.   (let* ((key (read-char))
  654.      (def (or (assq key (calc-user-key-map))
  655.           (assq (upcase key) (calc-user-key-map))
  656.           (assq (downcase key) (calc-user-key-map))
  657.           (error "No command defined for that key")))
  658.      (cmd (cdr def)))
  659.     (if (symbolp cmd)
  660.     (setq cmd (symbol-function cmd)))
  661.     (cond ((or (stringp cmd)
  662.            (and (consp cmd)
  663.             (eq (car-safe (nth 3 cmd)) 'calc-execute-kbd-macro)))
  664.        (if (and (>= (prefix-numeric-value prefix) 0)
  665.             (fboundp 'edit-kbd-macro)
  666.             (symbolp (cdr def))
  667.             (eq major-mode 'calc-mode))
  668.            (progn
  669.          (if (and (< (window-width) (screen-width))
  670.               calc-display-trail)
  671.              (let ((win (get-buffer-window (calc-trail-buffer))))
  672.                (if win
  673.                (delete-window win))))
  674.          (edit-kbd-macro (cdr def) prefix nil
  675.                  (function
  676.                   (lambda (x)
  677.                     (and calc-display-trail
  678.                      (calc-wrapper
  679.                       (calc-trail-display 1 t)))))
  680.                  (function
  681.                   (lambda (cmd)
  682.                     (if (stringp (symbol-function cmd))
  683.                     (symbol-function cmd)
  684.                       (let ((mac (nth 1 (nth 3 (symbol-function
  685.                                 cmd)))))
  686.                     (if (vectorp mac)
  687.                         (aref mac 1)
  688.                       mac)))))
  689.                  (function
  690.                   (lambda (new cmd)
  691.                     (if (stringp (symbol-function cmd))
  692.                     (fset cmd new)
  693.                       (let ((mac (cdr (nth 3 (symbol-function
  694.                                   cmd)))))
  695.                     (if (vectorp (car mac))
  696.                         (progn
  697.                           (aset (car mac) 0
  698.                             (key-description new))
  699.                           (aset (car mac) 1 new))
  700.                       (setcar mac new))))))))
  701.          (let ((keys (progn (and (fboundp 'edit-kbd-macro)
  702.                      (edit-kbd-macro nil))
  703.                 (fboundp 'MacEdit-parse-keys))))
  704.            (calc-wrapper
  705.         (calc-edit-mode (list 'calc-finish-macro-edit
  706.                       (list 'quote def)
  707.                       keys)
  708.                 t)
  709.         (if keys
  710.             (let (top
  711.               (fill-column 70)
  712.               (fill-prefix nil))
  713.               (insert "Notations: RET, SPC, TAB, DEL, LFD, NUL"
  714.                   ", C-xxx, M-xxx.\n\n")
  715.               (setq top (point))
  716.               (insert (if (stringp cmd)
  717.                   (key-description cmd)
  718.                 (if (vectorp (nth 1 (nth 3 cmd)))
  719.                     (aref (nth 1 (nth 3 cmd)) 0)
  720.                   (key-description (nth 1 (nth 3 cmd)))))
  721.                   "\n")
  722.               (if (>= (prog2 (forward-char -1)
  723.                      (current-column)
  724.                      (forward-char 1))
  725.                   (screen-width))
  726.               (fill-region top (point))))
  727.           (insert "Press C-q to quote control characters like RET"
  728.               " and TAB.\n"
  729.               (if (stringp cmd)
  730.                   cmd
  731.                 (if (vectorp (nth 1 (nth 3 cmd)))
  732.                 (aref (nth 1 (nth 3 cmd)) 1)
  733.                   (nth 1 (nth 3 cmd)))))))
  734.            (calc-show-edit-buffer)
  735.            (forward-line (if keys 2 1)))))
  736.       (t (let* ((func (calc-stack-command-p cmd))
  737.             (defn (and func
  738.                    (symbolp func)
  739.                    (get func 'calc-user-defn))))
  740.            (if (and defn (calc-valid-formula-func func))
  741.            (progn
  742.              (calc-wrapper
  743.               (calc-edit-mode (list 'calc-finish-formula-edit
  744.                         (list 'quote func)))
  745.               (insert (math-showing-full-precision
  746.                    (math-format-nice-expr defn (screen-width)))
  747.                   "\n"))
  748.              (calc-show-edit-buffer))
  749.          (error "That command's definition cannot be edited"))))))
  750. )
  751.  
  752. (defun calc-finish-macro-edit (def keys)
  753.   (forward-line 1)
  754.   (if (and keys (looking-at "\n")) (forward-line 1))
  755.   (let* ((true-str (buffer-substring (point) (point-max)))
  756.      (str true-str))
  757.     (if keys (setq str (MacEdit-parse-keys str)))
  758.     (if (symbolp (cdr def))
  759.     (if (stringp (symbol-function (cdr def)))
  760.         (fset (cdr def) str)
  761.       (let ((mac (cdr (nth 3 (symbol-function (cdr def))))))
  762.         (if (vectorp (car mac))
  763.         (progn
  764.           (aset (car mac) 0 (if keys true-str (key-description str)))
  765.           (aset (car mac) 1 str))
  766.           (setcar mac str))))
  767.       (setcdr def str)))
  768. )
  769.  
  770. ;;; The following are hooks into the MacEdit package from macedit.el.
  771. (put 'calc-execute-extended-command 'MacEdit-print
  772.      (function (lambda ()
  773.          (setq macro-str (concat "\excalc-" macro-str))))
  774. )
  775.  
  776. (put 'calcDigit-start 'MacEdit-print
  777.      (function (lambda ()
  778.          (if calc-algebraic-mode
  779.              (calc-macro-edit-algebraic)
  780.            (MacEdit-unread-chars key-last)
  781.            (let ((str "")
  782.              (min-bsp 0)
  783.              ch last)
  784.              (while (and (setq ch (MacEdit-read-char))
  785.                  (or (and (>= ch ?0) (<= ch ?9))
  786.                      (memq ch '(?\. ?e ?\_ ?n ?\: ?\# ?M
  787.                             ?o ?h ?\@ ?\"))
  788.                      (and (memq ch '(?\' ?m ?s))
  789.                       (string-match "[@oh]" str))
  790.                      (and (or (and (>= ch ?a) (<= ch ?z))
  791.                           (and (>= ch ?A) (<= ch ?Z)))
  792.                       (string-match
  793.                        "^[-+]?\\(1[1-9]\\|[2-9][0-9]\\)#"
  794.                        str))
  795.                      (and (memq ch '(?\177 ?\C-h))
  796.                       (> (length str) 0))
  797.                      (and (memq ch '(?+ ?-))
  798.                       (> (length str) 0)
  799.                       (eq (aref str (1- (length str)))
  800.                           ?e))))
  801.                (if (or (and (>= ch ?0) (<= ch ?9))
  802.                    (and (or (not (memq ch '(?\177 ?\C-h)))
  803.                     (<= (length str) min-bsp))
  804.                     (setq min-bsp (1+ (length str)))))
  805.                (setq str (concat str (char-to-string ch)))
  806.              (setq str (substring str 0 -1))))
  807.              (if (memq ch '(32 10 13))
  808.              (setq str (concat str (char-to-string ch)))
  809.                (MacEdit-unread-chars ch))
  810.              (insert "type \"")
  811.              (MacEdit-insert-string str)
  812.              (insert "\"\n")))))
  813. )
  814.  
  815. (defun calc-macro-edit-algebraic ()
  816.   (MacEdit-unread-chars key-last)
  817.   (let ((str "")
  818.     (min-bsp 0))
  819.     (while (progn
  820.          (MacEdit-lookup-key calc-alg-ent-map)
  821.          (or (and (memq key-symbol '(self-insert-command
  822.                      calcAlg-previous))
  823.               (< (length str) 60))
  824.          (memq key-symbol
  825.                 '(backward-delete-char
  826.                   delete-backward-char
  827.                   backward-delete-char-untabify))
  828.          (eq key-last 9)))
  829.       (setq macro-str (substring macro-str (length key-str)))
  830.       (if (or (eq key-symbol 'self-insert-command)
  831.           (and (or (not (memq key-symbol '(backward-delete-char
  832.                            delete-backward-char
  833.                            backward-delete-char-untabify)))
  834.                (<= (length str) min-bsp))
  835.            (setq min-bsp (+ (length str) (length key-str)))))
  836.       (setq str (concat str key-str))
  837.     (setq str (substring str 0 -1))))
  838.     (if (memq key-last '(10 13))
  839.     (setq str (concat str key-str)
  840.           macro-str (substring macro-str (length key-str))))
  841.     (if (> (length str) 0)
  842.     (progn
  843.       (insert "type \"")
  844.       (MacEdit-insert-string str)
  845.       (insert "\"\n"))))
  846. )
  847. (put 'calc-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
  848. (put 'calc-auto-algebraic-entry 'MacEdit-print 'calc-macro-edit-algebraic)
  849.  
  850. (defun calc-macro-edit-variable (&optional no-cmd)
  851.   (let ((str "") ch)
  852.     (or no-cmd (insert (symbol-name key-symbol) "\n"))
  853.     (if (memq (MacEdit-peek-char) '(?\+ ?\- ?\* ?\/ ?\^ ?\|))
  854.     (setq str (char-to-string (MacEdit-read-char))))
  855.     (if (and (setq ch (MacEdit-peek-char))
  856.          (>= ch ?0) (<= ch ?9))
  857.     (insert "type \"" str
  858.         (char-to-string (MacEdit-read-char)) "\"\n")
  859.       (if (> (length str) 0)
  860.       (insert "type \"" str "\"\n"))
  861.       (MacEdit-read-argument)))
  862. )
  863. (put 'calc-store 'MacEdit-print 'calc-macro-edit-variable)
  864. (put 'calc-store-into 'MacEdit-print 'calc-macro-edit-variable)
  865. (put 'calc-store-neg 'MacEdit-print 'calc-macro-edit-variable)
  866. (put 'calc-store-plus 'MacEdit-print 'calc-macro-edit-variable)
  867. (put 'calc-store-minus 'MacEdit-print 'calc-macro-edit-variable)
  868. (put 'calc-store-times 'MacEdit-print 'calc-macro-edit-variable)
  869. (put 'calc-store-div 'MacEdit-print 'calc-macro-edit-variable)
  870. (put 'calc-store-power 'MacEdit-print 'calc-macro-edit-variable)
  871. (put 'calc-store-concat 'MacEdit-print 'calc-macro-edit-variable)
  872. (put 'calc-store-inv 'MacEdit-print 'calc-macro-edit-variable)
  873. (put 'calc-store-decr 'MacEdit-print 'calc-macro-edit-variable)
  874. (put 'calc-store-incr 'MacEdit-print 'calc-macro-edit-variable)
  875. (put 'calc-store-exchange 'MacEdit-print 'calc-macro-edit-variable)
  876. (put 'calc-unstore 'MacEdit-print 'calc-macro-edit-variable)
  877. (put 'calc-recall 'MacEdit-print 'calc-macro-edit-variable)
  878. (put 'calc-let 'MacEdit-print 'calc-macro-edit-variable)
  879. (put 'calc-permanent-variable 'MacEdit-print 'calc-macro-edit-variable)
  880.  
  881. (defun calc-macro-edit-variable-2 ()
  882.   (calc-macro-edit-variable)
  883.   (calc-macro-edit-variable t)
  884. )
  885. (put 'calc-copy-variable 'MacEdit-print 'calc-macro-edit-variable-2)
  886. (put 'calc-declare-variable 'MacEdit-print 'calc-macro-edit-variable-2)
  887.  
  888. (defun calc-macro-edit-quick-digit ()
  889.   (insert "type \"" key-str "\"  # " (symbol-name key-symbol) "\n")
  890. )
  891. (put 'calc-store-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
  892. (put 'calc-store-into-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
  893. (put 'calc-recall-quick 'MacEdit-print 'calc-macro-edit-quick-digit)
  894. (put 'calc-select-part 'MacEdit-print 'calc-macro-edit-quick-digit)
  895. (put 'calc-clean-num 'MacEdit-print 'calc-macro-edit-quick-digit)
  896.  
  897.  
  898. (defun calc-finish-formula-edit (func)
  899.   (let ((buf (current-buffer))
  900.     (str (buffer-substring (point) (point-max)))
  901.     (start (point))
  902.     (body (calc-valid-formula-func func)))
  903.     (set-buffer calc-original-buffer)
  904.     (let ((val (math-read-expr str)))
  905.       (if (eq (car-safe val) 'error)
  906.       (progn
  907.         (set-buffer buf)
  908.         (goto-char (+ start (nth 1 val)))
  909.         (error (nth 2 val))))
  910.       (setcar (cdr body)
  911.           (let ((alist (nth 1 (symbol-function func))))
  912.         (calc-fix-user-formula val)))
  913.       (put func 'calc-user-defn val)))
  914. )
  915.  
  916. (defun calc-valid-formula-func (func)
  917.   (let ((def (symbol-function func)))
  918.     (and (consp def)
  919.      (eq (car def) 'lambda)
  920.      (progn
  921.        (setq def (cdr (cdr def)))
  922.        (while (and def
  923.                (not (eq (car (car def)) 'math-normalize)))
  924.          (setq def (cdr def)))
  925.        (car def))))
  926. )
  927.  
  928.  
  929. (defun calc-get-user-defn ()
  930.   (interactive)
  931.   (calc-wrapper
  932.    (message "Get definition of command: z-")
  933.    (let* ((key (read-char))
  934.       (def (or (assq key (calc-user-key-map))
  935.            (assq (upcase key) (calc-user-key-map))
  936.            (assq (downcase key) (calc-user-key-map))
  937.            (error "No command defined for that key")))
  938.       (cmd (cdr def)))
  939.      (if (symbolp cmd)
  940.      (setq cmd (symbol-function cmd)))
  941.      (cond ((stringp cmd)
  942.         (message "Keyboard macro: %s" cmd))
  943.        (t (let* ((func (calc-stack-command-p cmd))
  944.              (defn (and func
  945.                 (symbolp func)
  946.                 (get func 'calc-user-defn))))
  947.         (if defn
  948.             (progn
  949.               (and (calc-valid-formula-func func)
  950.                (setq defn (append '(calcFunc-lambda)
  951.                           (mapcar 'math-build-var-name
  952.                               (nth 1 (symbol-function
  953.                                   func)))
  954.                           (list defn))))
  955.               (calc-enter-result 0 "gdef" defn))
  956.           (error "That command is not defined by a formula")))))))
  957. )
  958.  
  959.  
  960. (defun calc-user-define-permanent ()
  961.   (interactive)
  962.   (calc-wrapper
  963.    (message "Record in %s the command: z-" calc-settings-file)
  964.    (let* ((key (read-char))
  965.       (def (or (assq key (calc-user-key-map))
  966.            (assq (upcase key) (calc-user-key-map))
  967.            (assq (downcase key) (calc-user-key-map))
  968.            (and (eq key ?\') 
  969.             (cons nil
  970.                   (intern (completing-read
  971.                        (format "Record in %s the function: "
  972.                            calc-settings-file)
  973.                        obarray 'fboundp nil "calcFunc-"))))
  974.            (error "No command defined for that key"))))
  975.      (set-buffer (find-file-noselect (substitute-in-file-name
  976.                       calc-settings-file)))
  977.      (goto-char (point-max))
  978.      (let* ((cmd (cdr def))
  979.         (fcmd (and cmd (symbolp cmd) (symbol-function cmd)))
  980.         (func nil)
  981.         (pt (point))
  982.         (fill-column 70)
  983.         (fill-prefix nil)
  984.         str q-ok)
  985.        (insert "\n;;; Definition stored by Calc on " (current-time-string)
  986.            "\n(put 'calc-define '"
  987.            (if (symbolp cmd) (symbol-name cmd) (format "key%d" key))
  988.            " '(progn\n")
  989.        (if (and fcmd
  990.         (eq (car-safe fcmd) 'lambda)
  991.         (get cmd 'calc-user-defn))
  992.        (let ((pt (point)))
  993.          (and (eq (car-safe (nth 3 fcmd)) 'calc-execute-kbd-macro)
  994.           (vectorp (nth 1 (nth 3 fcmd)))
  995.           (progn (and (fboundp 'edit-kbd-macro)
  996.                   (edit-kbd-macro nil))
  997.              (fboundp 'MacEdit-parse-keys))
  998.           (setq q-ok t)
  999.           (aset (nth 1 (nth 3 fcmd)) 1 nil))
  1000.          (insert (setq str (prin1-to-string
  1001.                 (cons 'defun (cons cmd (cdr fcmd)))))
  1002.              "\n")
  1003.          (or (and (string-match "\"" str) (not q-ok))
  1004.          (fill-region pt (point)))
  1005.          (indent-rigidly pt (point) 2)
  1006.          (delete-region pt (1+ pt))
  1007.          (insert " (put '" (symbol-name cmd)
  1008.              " 'calc-user-defn '"
  1009.              (prin1-to-string (get cmd 'calc-user-defn))
  1010.              ")\n")
  1011.          (setq func (calc-stack-command-p cmd))
  1012.          (let ((ffunc (and func (symbolp func) (symbol-function func)))
  1013.            (pt (point)))
  1014.            (and ffunc
  1015.             (eq (car-safe ffunc) 'lambda)
  1016.             (get func 'calc-user-defn)
  1017.             (progn
  1018.               (insert (setq str (prin1-to-string
  1019.                      (cons 'defun (cons func
  1020.                                 (cdr ffunc)))))
  1021.                   "\n")
  1022.               (or (and (string-match "\"" str) (not q-ok))
  1023.               (fill-region pt (point)))
  1024.               (indent-rigidly pt (point) 2)
  1025.               (delete-region pt (1+ pt))
  1026.               (setq pt (point))
  1027.               (insert "(put '" (symbol-name func)
  1028.                   " 'calc-user-defn '"
  1029.                   (prin1-to-string (get func 'calc-user-defn))
  1030.                   ")\n")
  1031.               (fill-region pt (point))
  1032.               (indent-rigidly pt (point) 2)
  1033.               (delete-region pt (1+ pt))))))
  1034.      (and (stringp fcmd)
  1035.           (insert " (fset '" (prin1-to-string cmd)
  1036.               " " (prin1-to-string fcmd) ")\n")))
  1037.        (or func (setq func (and cmd (symbolp cmd) (fboundp cmd) cmd)))
  1038.        (if (get func 'math-compose-forms)
  1039.        (let ((pt (point)))
  1040.          (insert "(put '" (symbol-name cmd)
  1041.              " 'math-compose-forms '"
  1042.              (prin1-to-string (get func 'math-compose-forms))
  1043.              ")\n")
  1044.          (fill-region pt (point))
  1045.          (indent-rigidly pt (point) 2)
  1046.          (delete-region pt (1+ pt))))
  1047.        (if (car def)
  1048.        (insert " (define-key calc-mode-map "
  1049.            (prin1-to-string (concat "z" (char-to-string key)))
  1050.            " '"
  1051.            (prin1-to-string cmd)
  1052.            ")\n")))
  1053.      (insert "))\n")
  1054.      (save-buffer)))
  1055. )
  1056.  
  1057. (defun calc-stack-command-p (cmd)
  1058.   (if (and cmd (symbolp cmd))
  1059.       (and (fboundp cmd)
  1060.        (calc-stack-command-p (symbol-function cmd)))
  1061.     (and (consp cmd)
  1062.      (eq (car cmd) 'lambda)
  1063.      (setq cmd (or (assq 'calc-wrapper cmd)
  1064.                (assq 'calc-slow-wrapper cmd)))
  1065.      (setq cmd (assq 'calc-enter-result cmd))
  1066.      (memq (car (nth 3 cmd)) '(cons list))
  1067.      (eq (car (nth 1 (nth 3 cmd))) 'quote)
  1068.      (nth 1 (nth 1 (nth 3 cmd)))))
  1069. )
  1070.  
  1071.  
  1072. (defun calc-call-last-kbd-macro (arg)
  1073.   (interactive "P")
  1074.   (and defining-kbd-macro
  1075.        (error "Can't execute anonymous macro while defining one"))
  1076.   (or last-kbd-macro
  1077.       (error "No kbd macro has been defined"))
  1078.   (calc-execute-kbd-macro last-kbd-macro arg)
  1079. )
  1080.  
  1081. (defun calc-execute-kbd-macro (mac arg &rest prefix)
  1082.   (if (vectorp mac)
  1083.       (setq mac (or (aref mac 1)
  1084.             (aset mac 1 (progn (and (fboundp 'edit-kbd-macro)
  1085.                         (edit-kbd-macro nil))
  1086.                        (MacEdit-parse-keys (aref mac 0)))))))
  1087.   (if (< (prefix-numeric-value arg) 0)
  1088.       (execute-kbd-macro mac (- (prefix-numeric-value arg)))
  1089.     (if calc-executing-macro
  1090.     (execute-kbd-macro mac arg)
  1091.       (calc-slow-wrapper
  1092.        (let ((old-stack-whole (copy-sequence calc-stack))
  1093.          (old-stack-top calc-stack-top)
  1094.          (old-buffer-size (buffer-size))
  1095.          (old-refresh-count calc-refresh-count))
  1096.      (unwind-protect
  1097.          (let ((calc-executing-macro mac))
  1098.            (execute-kbd-macro mac arg))
  1099.        (calc-select-buffer)
  1100.        (let ((new-stack (reverse calc-stack))
  1101.          (old-stack (reverse old-stack-whole)))
  1102.          (while (and new-stack old-stack
  1103.              (equal (car new-stack) (car old-stack)))
  1104.            (setq new-stack (cdr new-stack)
  1105.              old-stack (cdr old-stack)))
  1106.          (or (equal prefix '(nil))
  1107.          (calc-record-list (if (> (length new-stack) 1)
  1108.                        (mapcar 'car new-stack)
  1109.                      '(""))
  1110.                    (or (car prefix) "kmac")))
  1111.          (calc-record-undo (list 'set 'saved-stack-top old-stack-top))
  1112.          (and old-stack
  1113.           (calc-record-undo (list 'pop 1 (mapcar 'car old-stack))))
  1114.          (let ((calc-stack old-stack-whole)
  1115.            (calc-stack-top 0))
  1116.            (calc-cursor-stack-index (length old-stack)))
  1117.          (if (and (= old-buffer-size (buffer-size))
  1118.               (= old-refresh-count calc-refresh-count))
  1119.          (let ((buffer-read-only nil))
  1120.            (delete-region (point) (point-max))
  1121.            (while new-stack
  1122.              (calc-record-undo (list 'push 1))
  1123.              (insert (math-format-stack-value (car new-stack)) "\n")
  1124.              (setq new-stack (cdr new-stack)))
  1125.            (calc-renumber-stack))
  1126.            (while new-stack
  1127.          (calc-record-undo (list 'push 1))
  1128.          (setq new-stack (cdr new-stack)))
  1129.            (calc-refresh))
  1130.          (calc-record-undo (list 'set 'saved-stack-top 0))))))))
  1131. )
  1132.  
  1133. (defun calc-push-list-in-macro (vals m sels)
  1134.   (let ((entry (list (car vals) 1 (car sels)))
  1135.     (mm (+ (or m 1) calc-stack-top)))
  1136.     (if (> mm 1)
  1137.     (setcdr (nthcdr (- mm 2) calc-stack)
  1138.         (cons entry (nthcdr (1- mm) calc-stack)))
  1139.       (setq calc-stack (cons entry calc-stack))))
  1140. )
  1141.  
  1142. (defun calc-pop-stack-in-macro (n mm)
  1143.   (if (> mm 1)
  1144.       (setcdr (nthcdr (- mm 2) calc-stack)
  1145.           (nthcdr (+ n mm -1) calc-stack))
  1146.     (setq calc-stack (nthcdr n calc-stack)))
  1147. )
  1148.  
  1149.  
  1150. (defun calc-kbd-if ()
  1151.   (interactive)
  1152.   (calc-wrapper
  1153.    (let ((cond (calc-top-n 1)))
  1154.      (calc-pop-stack 1)
  1155.      (if (math-is-true cond)
  1156.      (if defining-kbd-macro
  1157.          (message "If true..."))
  1158.        (if defining-kbd-macro
  1159.        (message "Condition is false; skipping to Z: or Z] ..."))
  1160.        (calc-kbd-skip-to-else-if t))))
  1161. )
  1162.  
  1163. (defun calc-kbd-else-if ()
  1164.   (interactive)
  1165.   (calc-kbd-if)
  1166. )
  1167.  
  1168. (defun calc-kbd-skip-to-else-if (else-okay)
  1169.   (let ((count 0)
  1170.     ch)
  1171.     (while (>= count 0)
  1172.       (setq ch (read-char))
  1173.       (if (= ch -1)
  1174.       (error "Unterminated Z[ in keyboard macro"))
  1175.       (if (= ch ?Z)
  1176.       (progn
  1177.         (setq ch (read-char))
  1178.         (cond ((= ch ?\[)
  1179.            (setq count (1+ count)))
  1180.           ((= ch ?\])
  1181.            (setq count (1- count)))
  1182.           ((= ch ?\:)
  1183.            (and (= count 0)
  1184.             else-okay
  1185.             (setq count -1)))
  1186.           ((eq ch 7)
  1187.            (keyboard-quit))))))
  1188.     (and defining-kbd-macro
  1189.      (if (= ch ?\:)
  1190.          (message "Else...")
  1191.        (message "End-if..."))))
  1192. )
  1193.  
  1194. (defun calc-kbd-end-if ()
  1195.   (interactive)
  1196.   (if defining-kbd-macro
  1197.       (message "End-if..."))
  1198. )
  1199.  
  1200. (defun calc-kbd-else ()
  1201.   (interactive)
  1202.   (if defining-kbd-macro
  1203.       (message "Else; skipping to Z] ..."))
  1204.   (calc-kbd-skip-to-else-if nil)
  1205. )
  1206.  
  1207.  
  1208. (defun calc-kbd-repeat ()
  1209.   (interactive)
  1210.   (let (count)
  1211.     (calc-wrapper
  1212.      (setq count (math-trunc (calc-top-n 1)))
  1213.      (or (Math-integerp count)
  1214.      (error "Count must be an integer"))
  1215.      (if (Math-integer-negp count)
  1216.      (setq count 0))
  1217.      (or (integerp count)
  1218.      (setq count 1000000))
  1219.      (calc-pop-stack 1))
  1220.     (calc-kbd-loop count))
  1221. )
  1222.  
  1223. (defun calc-kbd-for (dir)
  1224.   (interactive "P")
  1225.   (let (init final)
  1226.     (calc-wrapper
  1227.      (setq init (calc-top-n 2)
  1228.        final (calc-top-n 1))
  1229.      (or (and (math-anglep init) (math-anglep final))
  1230.      (error "Initial and final values must be real numbers"))
  1231.      (calc-pop-stack 2))
  1232.     (calc-kbd-loop nil init final (and dir (prefix-numeric-value dir))))
  1233. )
  1234.  
  1235. (defun calc-kbd-loop (rpt-count &optional initial final dir)
  1236.   (interactive "P")
  1237.   (setq rpt-count (if rpt-count (prefix-numeric-value rpt-count) 1000000))
  1238.   (let* ((count 0)
  1239.      (parts nil)
  1240.      (body "")
  1241.      (open last-command-char)
  1242.      (counter initial)
  1243.      ch)
  1244.     (or executing-macro
  1245.     (message "Reading loop body..."))
  1246.     (while (>= count 0)
  1247.       (setq ch (read-char))
  1248.       (if (= ch -1)
  1249.       (error "Unterminated Z%c in keyboard macro" open))
  1250.       (if (= ch ?Z)
  1251.       (progn
  1252.         (setq ch (read-char)
  1253.           body (concat body "Z" (char-to-string ch)))
  1254.         (cond ((memq ch '(?\< ?\( ?\{))
  1255.            (setq count (1+ count)))
  1256.           ((memq ch '(?\> ?\) ?\}))
  1257.            (setq count (1- count)))
  1258.           ((and (= ch ?/)
  1259.             (= count 0))
  1260.            (setq parts (nconc parts (list (substring body 0 -2)))
  1261.              body ""))
  1262.           ((eq ch 7)
  1263.            (keyboard-quit))))
  1264.     (setq body (concat body (char-to-string ch)))))
  1265.     (if (/= ch (cdr (assq open '( (?\< . ?\>) (?\( . ?\)) (?\{ . ?\}) ))))
  1266.     (error "Mismatched Z%c and Z%c in keyboard macro" open ch))
  1267.     (or executing-macro
  1268.     (message "Looping..."))
  1269.     (setq body (substring body 0 -2))
  1270.     (and (not executing-macro)
  1271.      (= rpt-count 1000000)
  1272.      (null parts)
  1273.      (null counter)
  1274.      (progn
  1275.        (message "Warning: Infinite loop!  Not executing.")
  1276.        (setq rpt-count 0)))
  1277.     (or (not initial) dir
  1278.     (setq dir (math-compare final initial)))
  1279.     (calc-wrapper
  1280.      (while (> rpt-count 0)
  1281.        (let ((part parts))
  1282.      (if counter
  1283.          (if (cond ((eq dir 0) (Math-equal final counter))
  1284.                ((eq dir 1) (Math-lessp final counter))
  1285.                ((eq dir -1) (Math-lessp counter final)))
  1286.          (setq rpt-count 0)
  1287.            (calc-push counter)))
  1288.      (while (and part (> rpt-count 0))
  1289.        (execute-kbd-macro (car part))
  1290.        (if (math-is-true (calc-top-n 1))
  1291.            (setq rpt-count 0)
  1292.          (setq part (cdr part)))
  1293.        (calc-pop-stack 1))
  1294.      (if (> rpt-count 0)
  1295.          (progn
  1296.            (execute-kbd-macro body)
  1297.            (if counter
  1298.            (let ((step (calc-top-n 1)))
  1299.              (calc-pop-stack 1)
  1300.              (setq counter (calcFunc-add counter step)))
  1301.          (setq rpt-count (1- rpt-count))))))))
  1302.     (or executing-macro
  1303.     (message "Looping...done")))
  1304. )
  1305.  
  1306. (defun calc-kbd-end-repeat ()
  1307.   (interactive)
  1308.   (error "Unbalanced Z> in keyboard macro")
  1309. )
  1310.  
  1311. (defun calc-kbd-end-for ()
  1312.   (interactive)
  1313.   (error "Unbalanced Z) in keyboard macro")
  1314. )
  1315.  
  1316. (defun calc-kbd-end-loop ()
  1317.   (interactive)
  1318.   (error "Unbalanced Z} in keyboard macro")
  1319. )
  1320.  
  1321. (defun calc-kbd-break ()
  1322.   (interactive)
  1323.   (calc-wrapper
  1324.    (let ((cond (calc-top-n 1)))
  1325.      (calc-pop-stack 1)
  1326.      (if (math-is-true cond)
  1327.      (error "Keyboard macro aborted."))))
  1328. )
  1329.  
  1330.  
  1331. (defun calc-kbd-push (arg)
  1332.   (interactive "P")
  1333.   (calc-wrapper
  1334.    (let* ((defs (and arg (> (prefix-numeric-value arg) 0)))
  1335.       (var-q0 (and (boundp 'var-q0) var-q0))
  1336.       (var-q1 (and (boundp 'var-q1) var-q1))
  1337.       (var-q2 (and (boundp 'var-q2) var-q2))
  1338.       (var-q3 (and (boundp 'var-q3) var-q3))
  1339.       (var-q4 (and (boundp 'var-q4) var-q4))
  1340.       (var-q5 (and (boundp 'var-q5) var-q5))
  1341.       (var-q6 (and (boundp 'var-q6) var-q6))
  1342.       (var-q7 (and (boundp 'var-q7) var-q7))
  1343.       (var-q8 (and (boundp 'var-q8) var-q8))
  1344.       (var-q9 (and (boundp 'var-q9) var-q9))
  1345.       (calc-internal-prec (if defs 12 calc-internal-prec))
  1346.       (calc-word-size (if defs 32 calc-word-size))
  1347.       (calc-angle-mode (if defs 'deg calc-angle-mode))
  1348.       (calc-simplify-mode (if defs nil calc-simplify-mode))
  1349.       (calc-algebraic-mode (if arg nil calc-algebraic-mode))
  1350.       (calc-incomplete-algebraic-mode (if arg nil
  1351.                         calc-incomplete-algebraic-mode))
  1352.       (calc-symbolic-mode (if defs nil calc-symbolic-mode))
  1353.       (calc-matrix-mode (if defs nil calc-matrix-mode))
  1354.       (calc-prefer-frac (if defs nil calc-prefer-frac))
  1355.       (calc-complex-mode (if defs nil calc-complex-mode))
  1356.       (calc-infinite-mode (if defs nil calc-infinite-mode))
  1357.       (count 0)
  1358.       (body "")
  1359.       ch)
  1360.      (if (or executing-macro defining-kbd-macro)
  1361.      (progn
  1362.        (if defining-kbd-macro
  1363.            (message "Reading body..."))
  1364.        (while (>= count 0)
  1365.          (setq ch (read-char))
  1366.          (if (= ch -1)
  1367.          (error "Unterminated Z` in keyboard macro"))
  1368.          (if (= ch ?Z)
  1369.          (progn
  1370.            (setq ch (read-char)
  1371.              body (concat body "Z" (char-to-string ch)))
  1372.            (cond ((eq ch ?\`)
  1373.               (setq count (1+ count)))
  1374.              ((eq ch ?\')
  1375.               (setq count (1- count)))
  1376.              ((eq ch 7)
  1377.               (keyboard-quit))))
  1378.            (setq body (concat body (char-to-string ch)))))
  1379.        (if defining-kbd-macro
  1380.            (message "Reading body...done"))
  1381.        (let ((calc-kbd-push-level 0))
  1382.          (execute-kbd-macro (substring body 0 -2))))
  1383.        (let ((calc-kbd-push-level (1+ calc-kbd-push-level)))
  1384.      (message "Saving modes; type Z' to restore")
  1385.      (recursive-edit)))))
  1386. )
  1387. (setq calc-kbd-push-level 0)
  1388.  
  1389. (defun calc-kbd-pop ()
  1390.   (interactive)
  1391.   (if (> calc-kbd-push-level 0)
  1392.       (progn
  1393.     (message "Mode settings restored")
  1394.     (exit-recursive-edit))
  1395.     (error "Unbalanced Z' in keyboard macro"))
  1396. )
  1397.  
  1398.  
  1399. (defun calc-kbd-report (msg)
  1400.   (interactive "sMessage: ")
  1401.   (calc-wrapper
  1402.    (let ((executing-macro nil)
  1403.      (defining-kbd-macro nil))
  1404.      (math-working msg (calc-top-n 1))))
  1405. )
  1406.  
  1407. (defun calc-kbd-query (msg)
  1408.   (interactive "sPrompt: ")
  1409.   (calc-wrapper
  1410.    (let ((executing-macro nil)
  1411.      (defining-kbd-macro nil))
  1412.      (calc-alg-entry nil (and (not (equal msg "")) msg))))
  1413. )
  1414.  
  1415.  
  1416.  
  1417.  
  1418.  
  1419.  
  1420.  
  1421. ;;;; Logical operations.
  1422.  
  1423. (defun calcFunc-eq (a b &rest more)
  1424.   (if more
  1425.       (let* ((args (cons a (cons b (copy-sequence more))))
  1426.          (res 1)
  1427.          (p args)
  1428.          p2)
  1429.     (while (and (cdr p) (not (eq res 0)))
  1430.       (setq p2 p)
  1431.       (while (and (setq p2 (cdr p2)) (not (eq res 0)))
  1432.         (setq res (math-two-eq (car p) (car p2)))
  1433.         (if (eq res 1)
  1434.         (setcdr p (delq (car p2) (cdr p)))))
  1435.       (setq p (cdr p)))
  1436.     (if (eq res 0)
  1437.         0
  1438.       (if (cdr args)
  1439.           (cons 'calcFunc-eq args)
  1440.         1)))
  1441.     (or (math-two-eq a b)
  1442.     (if (and (or (math-looks-negp a) (math-zerop a))
  1443.          (or (math-looks-negp b) (math-zerop b)))
  1444.         (list 'calcFunc-eq (math-neg a) (math-neg b))
  1445.       (list 'calcFunc-eq a b))))
  1446. )
  1447.  
  1448. (defun calcFunc-neq (a b &rest more)
  1449.   (if more
  1450.       (let* ((args (cons a (cons b more)))
  1451.          (res 0)
  1452.          (all t)
  1453.          (p args)
  1454.          p2)
  1455.     (while (and (cdr p) (not (eq res 1)))
  1456.       (setq p2 p)
  1457.       (while (and (setq p2 (cdr p2)) (not (eq res 1)))
  1458.         (setq res (math-two-eq (car p) (car p2)))
  1459.         (or res (setq all nil)))
  1460.       (setq p (cdr p)))
  1461.     (if (eq res 1)
  1462.         0
  1463.       (if all
  1464.           1
  1465.         (cons 'calcFunc-neq args))))
  1466.     (or (cdr (assq (math-two-eq a b) '((0 . 1) (1 . 0))))
  1467.     (if (and (or (math-looks-negp a) (math-zerop a))
  1468.          (or (math-looks-negp b) (math-zerop b)))
  1469.         (list 'calcFunc-neq (math-neg a) (math-neg b))
  1470.       (list 'calcFunc-neq a b))))
  1471. )
  1472.  
  1473. (defun math-two-eq (a b)
  1474.   (if (eq (car-safe a) 'vec)
  1475.       (if (eq (car-safe b) 'vec)
  1476.       (if (= (length a) (length b))
  1477.           (let ((res 1))
  1478.         (while (and (setq a (cdr a) b (cdr b)) (not (eq res 0)))
  1479.           (if res
  1480.               (setq res (math-two-eq (car a) (car b)))
  1481.             (if (eq (math-two-eq (car a) (car b)) 0)
  1482.             (setq res 0))))
  1483.         res)
  1484.         0)
  1485.     (if (Math-objectp b)
  1486.         0
  1487.       nil))
  1488.     (if (eq (car-safe b) 'vec)
  1489.     (if (Math-objectp a)
  1490.         0
  1491.       nil)
  1492.       (let ((res (math-compare a b)))
  1493.     (if (= res 0)
  1494.         1
  1495.       (if (and (= res 2) (not (and (Math-scalarp a) (Math-scalarp b))))
  1496.           nil
  1497.         0)))))
  1498. )
  1499.  
  1500. (defun calcFunc-lt (a b)
  1501.   (let ((res (math-compare a b)))
  1502.     (if (= res -1)
  1503.     1
  1504.       (if (= res 2)
  1505.       (if (and (or (math-looks-negp a) (math-zerop a))
  1506.            (or (math-looks-negp b) (math-zerop b)))
  1507.           (list 'calcFunc-gt (math-neg a) (math-neg b))
  1508.         (list 'calcFunc-lt a b))
  1509.     0)))
  1510. )
  1511.  
  1512. (defun calcFunc-gt (a b)
  1513.   (let ((res (math-compare a b)))
  1514.     (if (= res 1)
  1515.     1
  1516.       (if (= res 2)
  1517.       (if (and (or (math-looks-negp a) (math-zerop a))
  1518.            (or (math-looks-negp b) (math-zerop b)))
  1519.           (list 'calcFunc-lt (math-neg a) (math-neg b))
  1520.         (list 'calcFunc-gt a b))
  1521.     0)))
  1522. )
  1523.  
  1524. (defun calcFunc-leq (a b)
  1525.   (let ((res (math-compare a b)))
  1526.     (if (= res 1)
  1527.     0
  1528.       (if (= res 2)
  1529.       (if (and (or (math-looks-negp a) (math-zerop a))
  1530.            (or (math-looks-negp b) (math-zerop b)))
  1531.           (list 'calcFunc-geq (math-neg a) (math-neg b))
  1532.         (list 'calcFunc-leq a b))
  1533.     1)))
  1534. )
  1535.  
  1536. (defun calcFunc-geq (a b)
  1537.   (let ((res (math-compare a b)))
  1538.     (if (= res -1)
  1539.     0
  1540.       (if (= res 2)
  1541.       (if (and (or (math-looks-negp a) (math-zerop a))
  1542.            (or (math-looks-negp b) (math-zerop b)))
  1543.           (list 'calcFunc-leq (math-neg a) (math-neg b))
  1544.         (list 'calcFunc-geq a b))
  1545.     1)))
  1546. )
  1547.  
  1548. (defun calcFunc-rmeq (a)
  1549.   (if (math-vectorp a)
  1550.       (math-map-vec 'calcFunc-rmeq a)
  1551.     (if (assq (car-safe a) calc-tweak-eqn-table)
  1552.     (if (and (eq (car-safe (nth 2 a)) 'var)
  1553.          (math-objectp (nth 1 a)))
  1554.         (nth 1 a)
  1555.       (nth 2 a))
  1556.       (if (eq (car-safe a) 'calcFunc-assign)
  1557.       (nth 2 a)
  1558.     (if (eq (car-safe a) 'calcFunc-evalto)
  1559.         (nth 1 a)
  1560.       (list 'calcFunc-rmeq a)))))
  1561. )
  1562.  
  1563. (defun calcFunc-land (a b)
  1564.   (cond ((Math-zerop a)
  1565.      a)
  1566.     ((Math-zerop b)
  1567.      b)
  1568.     ((math-is-true a)
  1569.      b)
  1570.     ((math-is-true b)
  1571.      a)
  1572.     (t (list 'calcFunc-land a b)))
  1573. )
  1574.  
  1575. (defun calcFunc-lor (a b)
  1576.   (cond ((Math-zerop a)
  1577.      b)
  1578.     ((Math-zerop b)
  1579.      a)
  1580.     ((math-is-true a)
  1581.      a)
  1582.     ((math-is-true b)
  1583.      b)
  1584.     (t (list 'calcFunc-lor a b)))
  1585. )
  1586.  
  1587. (defun calcFunc-lnot (a)
  1588.   (if (Math-zerop a)
  1589.       1
  1590.     (if (math-is-true a)
  1591.     0
  1592.       (let ((op (and (= (length a) 3)
  1593.              (assq (car a) calc-tweak-eqn-table))))
  1594.     (if op
  1595.         (cons (nth 2 op) (cdr a))
  1596.       (list 'calcFunc-lnot a)))))
  1597. )
  1598.  
  1599. (defun calcFunc-if (c e1 e2)
  1600.   (if (Math-zerop c)
  1601.       e2
  1602.     (if (and (math-is-true c) (not (Math-vectorp c)))
  1603.     e1
  1604.       (or (and (Math-vectorp c)
  1605.            (math-constp c)
  1606.            (let ((ee1 (if (Math-vectorp e1)
  1607.                   (if (= (length c) (length e1))
  1608.                   (cdr e1)
  1609.                 (calc-record-why "*Dimension error" e1))
  1610.                 (list e1)))
  1611.              (ee2 (if (Math-vectorp e2)
  1612.                   (if (= (length c) (length e2))
  1613.                   (cdr e2)
  1614.                 (calc-record-why "*Dimension error" e2))
  1615.                 (list e2))))
  1616.          (and ee1 ee2
  1617.               (cons 'vec (math-if-vector (cdr c) ee1 ee2)))))
  1618.       (list 'calcFunc-if c e1 e2))))
  1619. )
  1620.  
  1621. (defun math-if-vector (c e1 e2)
  1622.   (and c
  1623.        (cons (if (Math-zerop (car c)) (car e2) (car e1))
  1624.          (math-if-vector (cdr c)
  1625.                  (or (cdr e1) e1)
  1626.                  (or (cdr e2) e2))))
  1627. )
  1628.  
  1629. (defun math-normalize-logical-op (a)
  1630.   (or (and (eq (car a) 'calcFunc-if)
  1631.        (= (length a) 4)
  1632.        (let ((a1 (math-normalize (nth 1 a))))
  1633.          (if (Math-zerop a1)
  1634.          (math-normalize (nth 3 a))
  1635.            (if (Math-numberp a1)
  1636.            (math-normalize (nth 2 a))
  1637.          (if (and (Math-vectorp (nth 1 a))
  1638.               (math-constp (nth 1 a)))
  1639.              (calcFunc-if (nth 1 a)
  1640.                   (math-normalize (nth 2 a))
  1641.                   (math-normalize (nth 3 a)))
  1642.            (let ((calc-simplify-mode 'none))
  1643.              (list 'calcFunc-if a1
  1644.                (math-normalize (nth 2 a))
  1645.                (math-normalize (nth 3 a)))))))))
  1646.       a)
  1647. )
  1648.  
  1649. (defun calcFunc-in (a b)
  1650.   (or (and (eq (car-safe b) 'vec)
  1651.        (let ((bb b))
  1652.          (while (and (setq bb (cdr bb))
  1653.              (not (if (memq (car-safe (car bb)) '(vec intv))
  1654.                   (eq (calcFunc-in a (car bb)) 1)
  1655.                 (Math-equal a (car bb))))))
  1656.          (if bb 1 (and (math-constp a) (math-constp bb) 0))))
  1657.       (and (eq (car-safe b) 'intv)
  1658.        (let ((res (math-compare a (nth 2 b))) res2)
  1659.          (cond ((= res -1)
  1660.             0)
  1661.            ((and (= res 0)
  1662.              (or (/= (nth 1 b) 2)
  1663.                  (Math-lessp (nth 2 b) (nth 3 b))))
  1664.             (if (memq (nth 1 b) '(2 3)) 1 0))
  1665.            ((= (setq res2 (math-compare a (nth 3 b))) 1)
  1666.             0)
  1667.            ((and (= res2 0)
  1668.              (or (/= (nth 1 b) 1)
  1669.                  (Math-lessp (nth 2 b) (nth 3 b))))
  1670.             (if (memq (nth 1 b) '(1 3)) 1 0))
  1671.            ((/= res 1)
  1672.             nil)
  1673.            ((/= res2 -1)
  1674.             nil)
  1675.            (t 1))))
  1676.       (and (Math-equal a b)
  1677.        1)
  1678.       (and (math-constp a) (math-constp b)
  1679.        0)
  1680.       (list 'calcFunc-in a b))
  1681. )
  1682.  
  1683. (defun calcFunc-typeof (a)
  1684.   (cond ((Math-integerp a) 1)
  1685.     ((eq (car a) 'frac) 2)
  1686.     ((eq (car a) 'float) 3)
  1687.     ((eq (car a) 'hms) 4)
  1688.     ((eq (car a) 'cplx) 5)
  1689.     ((eq (car a) 'polar) 6)
  1690.     ((eq (car a) 'sdev) 7)
  1691.     ((eq (car a) 'intv) 8)
  1692.     ((eq (car a) 'mod) 9)
  1693.     ((eq (car a) 'date) (if (Math-integerp (nth 1 a)) 10 11))
  1694.     ((eq (car a) 'var)
  1695.      (if (memq (nth 2 a) '(var-inf var-uinf var-nan)) 12 100))
  1696.     ((eq (car a) 'vec) (if (math-matrixp a) 102 101))
  1697.     (t (math-calcFunc-to-var func)))
  1698. )
  1699.  
  1700. (defun calcFunc-integer (a)
  1701.   (if (Math-integerp a)
  1702.       1
  1703.     (if (Math-objvecp a)
  1704.     0
  1705.       (list 'calcFunc-integer a)))
  1706. )
  1707.  
  1708. (defun calcFunc-real (a)
  1709.   (if (Math-realp a)
  1710.       1
  1711.     (if (Math-objvecp a)
  1712.     0
  1713.       (list 'calcFunc-real a)))
  1714. )
  1715.  
  1716. (defun calcFunc-constant (a)
  1717.   (if (math-constp a)
  1718.       1
  1719.     (if (Math-objvecp a)
  1720.     0
  1721.       (list 'calcFunc-constant a)))
  1722. )
  1723.  
  1724. (defun calcFunc-refers (a b)
  1725.   (if (math-expr-contains a b)
  1726.       1
  1727.     (if (eq (car-safe a) 'var)
  1728.     (list 'calcFunc-refers a b)
  1729.       0))
  1730. )
  1731.  
  1732. (defun calcFunc-negative (a)
  1733.   (if (math-looks-negp a)
  1734.       1
  1735.     (if (or (math-zerop a)
  1736.         (math-posp a))
  1737.     0
  1738.       (list 'calcFunc-negative a)))
  1739. )
  1740.  
  1741. (defun calcFunc-variable (a)
  1742.   (if (eq (car-safe a) 'var)
  1743.       1
  1744.     (if (Math-objvecp a)
  1745.     0
  1746.       (list 'calcFunc-variable a)))
  1747. )
  1748.  
  1749. (defun calcFunc-nonvar (a)
  1750.   (if (eq (car-safe a) 'var)
  1751.       (list 'calcFunc-nonvar a)
  1752.     1)
  1753. )
  1754.  
  1755. (defun calcFunc-istrue (a)
  1756.   (if (math-is-true a)
  1757.       1
  1758.     0)
  1759. )
  1760.  
  1761.  
  1762.  
  1763.  
  1764. ;;;; User-programmability.
  1765.  
  1766. ;;; Compiling Lisp-like forms to use the math library.
  1767.  
  1768. (defun math-do-defmath (func args body)
  1769.   (calc-need-macros)
  1770.   (let* ((fname (intern (concat "calcFunc-" (symbol-name func))))
  1771.      (doc (if (stringp (car body)) (list (car body))))
  1772.      (clargs (mapcar 'math-clean-arg args))
  1773.      (body (math-define-function-body
  1774.         (if (stringp (car body)) (cdr body) body)
  1775.         clargs)))
  1776.     (list 'progn
  1777.       (if (and (consp (car body))
  1778.            (eq (car (car body)) 'interactive))
  1779.           (let ((inter (car body)))
  1780.         (setq body (cdr body))
  1781.         (if (or (> (length inter) 2)
  1782.             (integerp (nth 1 inter)))
  1783.             (let ((hasprefix nil) (hasmulti nil))
  1784.               (if (stringp (nth 1 inter))
  1785.               (progn
  1786.                 (cond ((equal (nth 1 inter) "p")
  1787.                    (setq hasprefix t))
  1788.                   ((equal (nth 1 inter) "m")
  1789.                    (setq hasmulti t))
  1790.                   (t (error
  1791.                       "Can't handle interactive code string \"%s\""
  1792.                       (nth 1 inter))))
  1793.                 (setq inter (cdr inter))))
  1794.               (if (not (integerp (nth 1 inter)))
  1795.               (error
  1796.                "Expected an integer in interactive specification"))
  1797.               (append (list 'defun
  1798.                     (intern (concat "calc-"
  1799.                             (symbol-name func)))
  1800.                     (if (or hasprefix hasmulti)
  1801.                     '(&optional n)
  1802.                       ()))
  1803.                   doc
  1804.                   (if (or hasprefix hasmulti)
  1805.                   '((interactive "P"))
  1806.                 '((interactive)))
  1807.                   (list
  1808.                    (append
  1809.                 '(calc-slow-wrapper)
  1810.                 (and hasmulti
  1811.                      (list
  1812.                       (list 'setq
  1813.                         'n
  1814.                         (list 'if
  1815.                           'n
  1816.                           (list 'prefix-numeric-value
  1817.                             'n)
  1818.                           (nth 1 inter)))))
  1819.                 (list
  1820.                  (list 'calc-enter-result
  1821.                        (if hasmulti 'n (nth 1 inter))
  1822.                        (nth 2 inter)
  1823.                        (if hasprefix
  1824.                        (list 'append
  1825.                          (list 'quote (list fname))
  1826.                          (list 'calc-top-list-n
  1827.                                (nth 1 inter))
  1828.                          (list 'and
  1829.                                'n
  1830.                                (list
  1831.                             'list
  1832.                             (list
  1833.                              'math-normalize
  1834.                              (list
  1835.                               'prefix-numeric-value
  1836.                               'n)))))
  1837.                      (list 'cons
  1838.                            (list 'quote fname)
  1839.                            (list 'calc-top-list-n
  1840.                              (if hasmulti
  1841.                              'n
  1842.                                (nth 1 inter)))))))))))
  1843.           (append (list 'defun
  1844.                 (intern (concat "calc-" (symbol-name func)))
  1845.                 args)
  1846.               doc
  1847.               (list
  1848.                inter
  1849.                (cons 'calc-wrapper body))))))
  1850.       (append (list 'defun fname clargs)
  1851.           doc
  1852.           (math-do-arg-list-check args nil nil)
  1853.           body)))
  1854. )
  1855.  
  1856. (defun math-clean-arg (arg)
  1857.   (if (consp arg)
  1858.       (math-clean-arg (nth 1 arg))
  1859.     arg)
  1860. )
  1861.  
  1862. (defun math-do-arg-check (arg var is-opt is-rest)
  1863.   (if is-opt
  1864.       (let ((chk (math-do-arg-check arg var nil nil)))
  1865.     (list (cons 'and
  1866.             (cons var
  1867.               (if (cdr chk)
  1868.                   (setq chk (list (cons 'progn chk)))
  1869.                 chk)))))
  1870.     (and (consp arg)
  1871.      (let* ((rest (math-do-arg-check (nth 1 arg) var is-opt is-rest))
  1872.         (qual (car arg))
  1873.         (qqual (list 'quote qual))
  1874.         (qual-name (symbol-name qual))
  1875.         (chk (intern (concat "math-check-" qual-name))))
  1876.        (if (fboundp chk)
  1877.            (append rest
  1878.                (list
  1879.             (if is-rest
  1880.                 (list 'setq var
  1881.                   (list 'mapcar (list 'quote chk) var))
  1882.               (list 'setq var (list chk var)))))
  1883.          (if (fboundp (setq chk (intern (concat "math-" qual-name))))
  1884.          (append rest
  1885.              (list
  1886.               (if is-rest
  1887.                   (list 'mapcar
  1888.                     (list 'function
  1889.                       (list 'lambda '(x)
  1890.                         (list 'or
  1891.                               (list chk 'x)
  1892.                               (list 'math-reject-arg
  1893.                                 'x qqual))))
  1894.                     var)
  1895.                 (list 'or
  1896.                   (list chk var)
  1897.                   (list 'math-reject-arg var qqual)))))
  1898.            (if (and (string-match "\\`not-\\(.*\\)\\'" qual-name)
  1899.             (fboundp (setq chk (intern
  1900.                         (concat "math-"
  1901.                             (math-match-substring
  1902.                              qual-name 1))))))
  1903.            (append rest
  1904.                (list
  1905.                 (if is-rest
  1906.                 (list 'mapcar
  1907.                       (list 'function
  1908.                         (list 'lambda '(x)
  1909.                           (list 'and
  1910.                             (list chk 'x)
  1911.                             (list 'math-reject-arg
  1912.                                   'x qqual))))
  1913.                       var)
  1914.                   (list 'and
  1915.                     (list chk var)
  1916.                     (list 'math-reject-arg var qqual)))))
  1917.          (error "Unknown qualifier `%s'" qual-name)))))))
  1918. )
  1919.  
  1920. (defun math-do-arg-list-check (args is-opt is-rest)
  1921.   (cond ((null args) nil)
  1922.     ((consp (car args))
  1923.      (append (math-do-arg-check (car args)
  1924.                     (math-clean-arg (car args))
  1925.                     is-opt is-rest)
  1926.          (math-do-arg-list-check (cdr args) is-opt is-rest)))
  1927.     ((eq (car args) '&optional)
  1928.      (math-do-arg-list-check (cdr args) t nil))
  1929.     ((eq (car args) '&rest)
  1930.      (math-do-arg-list-check (cdr args) nil t))
  1931.     (t (math-do-arg-list-check (cdr args) is-opt is-rest)))
  1932. )
  1933.  
  1934. (defconst math-prim-funcs
  1935.   '( (~= . math-nearly-equal)
  1936.      (% . math-mod)
  1937.      (lsh . calcFunc-lsh)
  1938.      (ash . calcFunc-ash)
  1939.      (logand . calcFunc-and)
  1940.      (logandc2 . calcFunc-diff)
  1941.      (logior . calcFunc-or)
  1942.      (logxor . calcFunc-xor)
  1943.      (lognot . calcFunc-not)
  1944.      (equal . equal)   ; need to leave these ones alone!
  1945.      (eq . eq)
  1946.      (and . and)
  1947.      (or . or)
  1948.      (if . if)
  1949.      (^ . math-pow)
  1950.      (expt . math-pow)
  1951.    )
  1952. )
  1953.  
  1954. (defconst math-prim-vars
  1955.   '( (nil . nil)
  1956.      (t . t)
  1957.      (&optional . &optional)
  1958.      (&rest . &rest)
  1959.    )
  1960. )
  1961.  
  1962. (defun math-define-function-body (body env)
  1963.   (let ((body (math-define-body body env)))
  1964.     (if (math-body-refers-to body 'math-return)
  1965.     (list (cons 'catch (cons '(quote math-return) body)))
  1966.       body))
  1967. )
  1968.  
  1969. (defun math-define-body (body exp-env)
  1970.   (math-define-list body)
  1971. )
  1972.  
  1973. (defun math-define-list (body &optional quote)
  1974.   (cond ((null body)
  1975.      nil)
  1976.     ((and (eq (car body) ':)
  1977.           (stringp (nth 1 body)))
  1978.      (cons (let* ((math-read-expr-quotes t)
  1979.               (exp (math-read-plain-expr (nth 1 body) t)))
  1980.          (math-define-exp exp))
  1981.            (math-define-list (cdr (cdr body)))))
  1982.     (quote
  1983.      (cons (cond ((consp (car body))
  1984.               (math-define-list (cdr body) t))
  1985.              (t
  1986.               (car body)))
  1987.            (math-define-list (cdr body))))
  1988.     (t
  1989.      (cons (math-define-exp (car body))
  1990.            (math-define-list (cdr body)))))
  1991. )
  1992.  
  1993. (defun math-define-exp (exp)
  1994.   (cond ((consp exp)
  1995.      (let ((func (car exp)))
  1996.        (cond ((memq func '(quote function))
  1997.           (if (and (consp (nth 1 exp))
  1998.                (eq (car (nth 1 exp)) 'lambda))
  1999.               (cons 'quote
  2000.                 (math-define-lambda (nth 1 exp) exp-env))
  2001.             exp))
  2002.          ((memq func '(let let* for foreach))
  2003.           (let ((head (nth 1 exp))
  2004.             (body (cdr (cdr exp))))
  2005.             (if (memq func '(let let*))
  2006.             ()
  2007.               (setq func (cdr (assq func '((for . math-for)
  2008.                            (foreach . math-foreach)))))
  2009.               (if (not (listp (car head)))
  2010.               (setq head (list head))))
  2011.             (macroexpand
  2012.              (cons func
  2013.                (cons (math-define-let head)
  2014.                  (math-define-body body
  2015.                            (nconc
  2016.                             (math-define-let-env head)
  2017.                             exp-env)))))))
  2018.          ((and (memq func '(setq setf))
  2019.                (math-complicated-lhs (cdr exp)))
  2020.           (if (> (length exp) 3)
  2021.               (cons 'progn (math-define-setf-list (cdr exp)))
  2022.             (math-define-setf (nth 1 exp) (nth 2 exp))))
  2023.          ((eq func 'condition-case)
  2024.           (cons func
  2025.             (cons (nth 1 exp)
  2026.                   (math-define-body (cdr (cdr exp))
  2027.                         (cons (nth 1 exp)
  2028.                               exp-env)))))
  2029.          ((eq func 'cond)
  2030.           (cons func
  2031.             (math-define-cond (cdr exp))))
  2032.          ((and (consp func)   ; ('spam a b) == force use of plain spam
  2033.                (eq (car func) 'quote))
  2034.           (cons func (math-define-list (cdr exp))))
  2035.          ((symbolp func)
  2036.           (let ((args (math-define-list (cdr exp)))
  2037.             (prim (assq func math-prim-funcs)))
  2038.             (cond (prim
  2039.                (cons (cdr prim) args))
  2040.               ((eq func 'floatp)
  2041.                (list 'eq (car args) '(quote float)))
  2042.               ((eq func '+)
  2043.                (math-define-binop 'math-add 0
  2044.                           (car args) (cdr args)))
  2045.               ((eq func '-)
  2046.                (if (= (length args) 1)
  2047.                    (cons 'math-neg args)
  2048.                  (math-define-binop 'math-sub 0
  2049.                         (car args) (cdr args))))
  2050.               ((eq func '*)
  2051.                (math-define-binop 'math-mul 1
  2052.                           (car args) (cdr args)))
  2053.               ((eq func '/)
  2054.                (math-define-binop 'math-div 1
  2055.                           (car args) (cdr args)))
  2056.               ((eq func 'min)
  2057.                (math-define-binop 'math-min 0
  2058.                           (car args) (cdr args)))
  2059.               ((eq func 'max)
  2060.                (math-define-binop 'math-max 0
  2061.                           (car args) (cdr args)))
  2062.               ((eq func '<)
  2063.                (if (and (math-numberp (nth 1 args))
  2064.                     (math-zerop (nth 1 args)))
  2065.                    (list 'math-negp (car args))
  2066.                  (cons 'math-lessp args)))
  2067.               ((eq func '>)
  2068.                (if (and (math-numberp (nth 1 args))
  2069.                     (math-zerop (nth 1 args)))
  2070.                    (list 'math-posp (car args))
  2071.                  (list 'math-lessp (nth 1 args) (nth 0 args))))
  2072.               ((eq func '<=)
  2073.                (list 'not
  2074.                  (if (and (math-numberp (nth 1 args))
  2075.                       (math-zerop (nth 1 args)))
  2076.                      (list 'math-posp (car args))
  2077.                    (list 'math-lessp
  2078.                      (nth 1 args) (nth 0 args)))))
  2079.               ((eq func '>=)
  2080.                (list 'not
  2081.                  (if (and (math-numberp (nth 1 args))
  2082.                       (math-zerop (nth 1 args)))
  2083.                      (list 'math-negp (car args))
  2084.                    (cons 'math-lessp args))))
  2085.               ((eq func '=)
  2086.                (if (and (math-numberp (nth 1 args))
  2087.                     (math-zerop (nth 1 args)))
  2088.                    (list 'math-zerop (nth 0 args))
  2089.                  (if (and (integerp (nth 1 args))
  2090.                       (/= (% (nth 1 args) 10) 0))
  2091.                  (cons 'math-equal-int args)
  2092.                    (cons 'math-equal args))))
  2093.               ((eq func '/=)
  2094.                (list 'not
  2095.                  (if (and (math-numberp (nth 1 args))
  2096.                       (math-zerop (nth 1 args)))
  2097.                      (list 'math-zerop (nth 0 args))
  2098.                    (if (and (integerp (nth 1 args))
  2099.                         (/= (% (nth 1 args) 10) 0))
  2100.                        (cons 'math-equal-int args)
  2101.                      (cons 'math-equal args)))))
  2102.               ((eq func '1+)
  2103.                (list 'math-add (car args) 1))
  2104.               ((eq func '1-)
  2105.                (list 'math-add (car args) -1))
  2106.               ((eq func 'not)   ; optimize (not (not x)) => x
  2107.                (if (eq (car-safe args) func)
  2108.                    (car (nth 1 args))
  2109.                  (cons func args)))
  2110.               ((and (eq func 'elt) (cdr (cdr args)))
  2111.                (math-define-elt (car args) (cdr args)))
  2112.               (t
  2113.                (macroexpand
  2114.                 (let* ((name (symbol-name func))
  2115.                    (cfunc (intern (concat "calcFunc-" name)))
  2116.                    (mfunc (intern (concat "math-" name))))
  2117.                   (cond ((fboundp cfunc)
  2118.                      (cons cfunc args))
  2119.                     ((fboundp mfunc)
  2120.                      (cons mfunc args))
  2121.                     ((or (fboundp func)
  2122.                      (string-match "\\`calcFunc-.*" name))
  2123.                      (cons func args))
  2124.                     (t
  2125.                      (cons cfunc args)))))))))
  2126.          (t (cons func args)))))
  2127.     ((symbolp exp)
  2128.      (let ((prim (assq exp math-prim-vars))
  2129.            (name (symbol-name exp)))
  2130.        (cond (prim
  2131.           (cdr prim))
  2132.          ((memq exp exp-env)
  2133.           exp)
  2134.          ((string-match "-" name)
  2135.           exp)
  2136.          (t
  2137.           (intern (concat "var-" name))))))
  2138.     ((integerp exp)
  2139.      (if (or (<= exp -1000000) (>= exp 1000000))
  2140.          (list 'quote (math-normalize exp))
  2141.        exp))
  2142.     (t exp))
  2143. )
  2144.  
  2145. (defun math-define-cond (forms)
  2146.   (and forms
  2147.        (cons (math-define-list (car forms))
  2148.          (math-define-cond (cdr forms))))
  2149. )
  2150.  
  2151. (defun math-complicated-lhs (body)
  2152.   (and body
  2153.        (or (not (symbolp (car body)))
  2154.        (math-complicated-lhs (cdr (cdr body)))))
  2155. )
  2156.  
  2157. (defun math-define-setf-list (body)
  2158.   (and body
  2159.        (cons (math-define-setf (nth 0 body) (nth 1 body))
  2160.          (math-define-setf-list (cdr (cdr body)))))
  2161. )
  2162.  
  2163. (defun math-define-setf (place value)
  2164.   (setq place (math-define-exp place)
  2165.     value (math-define-exp value))
  2166.   (cond ((symbolp place)
  2167.      (list 'setq place value))
  2168.     ((eq (car-safe place) 'nth)
  2169.      (list 'setcar (list 'nthcdr (nth 1 place) (nth 2 place)) value))
  2170.     ((eq (car-safe place) 'elt)
  2171.      (list 'setcar (list 'nthcdr (nth 2 place) (nth 1 place)) value))
  2172.     ((eq (car-safe place) 'car)
  2173.      (list 'setcar (nth 1 place) value))
  2174.     ((eq (car-safe place) 'cdr)
  2175.      (list 'setcdr (nth 1 place) value))
  2176.     (t
  2177.      (error "Bad place form for setf: %s" place)))
  2178. )
  2179.  
  2180. (defun math-define-binop (op ident arg1 rest)
  2181.   (if rest
  2182.       (math-define-binop op ident
  2183.              (list op arg1 (car rest))
  2184.              (cdr rest))
  2185.     (or arg1 ident))
  2186. )
  2187.  
  2188. (defun math-define-let (vlist)
  2189.   (and vlist
  2190.        (cons (if (consp (car vlist))
  2191.          (cons (car (car vlist))
  2192.                (math-define-list (cdr (car vlist))))
  2193.            (car vlist))
  2194.          (math-define-let (cdr vlist))))
  2195. )
  2196.  
  2197. (defun math-define-let-env (vlist)
  2198.   (and vlist
  2199.        (cons (if (consp (car vlist))
  2200.          (car (car vlist))
  2201.            (car vlist))
  2202.          (math-define-let-env (cdr vlist))))
  2203. )
  2204.  
  2205. (defun math-define-lambda (exp exp-env)
  2206.   (nconc (list (nth 0 exp)   ; 'lambda
  2207.            (nth 1 exp))  ; arg list
  2208.      (math-define-function-body (cdr (cdr exp))
  2209.                     (append (nth 1 exp) exp-env)))
  2210. )
  2211.  
  2212. (defun math-define-elt (seq idx)
  2213.   (if idx
  2214.       (math-define-elt (list 'elt seq (car idx)) (cdr idx))
  2215.     seq)
  2216. )
  2217.  
  2218.  
  2219.  
  2220. ;;; Useful programming macros.
  2221.  
  2222. (defmacro math-while (head &rest body)
  2223.   (let ((body (cons 'while (cons head body))))
  2224.     (if (math-body-refers-to body 'math-break)
  2225.     (cons 'catch (cons '(quote math-break) (list body)))
  2226.       body))
  2227. )
  2228.  
  2229.  
  2230. (defmacro math-for (head &rest body)
  2231.   (let ((body (if head
  2232.           (math-handle-for head body)
  2233.         (cons 'while (cons t body)))))
  2234.     (if (math-body-refers-to body 'math-break)
  2235.     (cons 'catch (cons '(quote math-break) (list body)))
  2236.       body))
  2237. )
  2238.  
  2239. (defun math-handle-for (head body)
  2240.   (let* ((var (nth 0 (car head)))
  2241.      (init (nth 1 (car head)))
  2242.      (limit (nth 2 (car head)))
  2243.      (step (or (nth 3 (car head)) 1))
  2244.      (body (if (cdr head)
  2245.            (list (math-handle-for (cdr head) body))
  2246.          body))
  2247.      (all-ints (and (integerp init) (integerp limit) (integerp step)))
  2248.      (const-limit (or (integerp limit)
  2249.               (and (eq (car-safe limit) 'quote)
  2250.                    (math-realp (nth 1 limit)))))
  2251.      (const-step (or (integerp step)
  2252.              (and (eq (car-safe step) 'quote)
  2253.                   (math-realp (nth 1 step)))))
  2254.      (save-limit (if const-limit limit (make-symbol "<limit>")))
  2255.      (save-step (if const-step step (make-symbol "<step>"))))
  2256.     (cons 'let
  2257.       (cons (append (if const-limit nil (list (list save-limit limit)))
  2258.             (if const-step nil (list (list save-step step)))
  2259.             (list (list var init)))
  2260.         (list
  2261.          (cons 'while
  2262.                (cons (if all-ints
  2263.                  (if (> step 0)
  2264.                      (list '<= var save-limit)
  2265.                    (list '>= var save-limit))
  2266.                    (list 'not
  2267.                      (if const-step
  2268.                      (if (or (math-posp step)
  2269.                          (math-posp
  2270.                           (cdr-safe step)))
  2271.                          (list 'math-lessp
  2272.                            save-limit
  2273.                            var)
  2274.                        (list 'math-lessp
  2275.                          var
  2276.                          save-limit))
  2277.                        (list 'if
  2278.                          (list 'math-posp
  2279.                            save-step)
  2280.                          (list 'math-lessp
  2281.                            save-limit
  2282.                            var)
  2283.                          (list 'math-lessp
  2284.                            var
  2285.                            save-limit)))))
  2286.                  (append body
  2287.                      (list (list 'setq
  2288.                          var
  2289.                          (list (if all-ints
  2290.                                '+
  2291.                              'math-add)
  2292.                                var
  2293.                                save-step))))))))))
  2294. )
  2295.  
  2296.  
  2297. (defmacro math-foreach (head &rest body)
  2298.   (let ((body (math-handle-foreach head body)))
  2299.     (if (math-body-refers-to body 'math-break)
  2300.     (cons 'catch (cons '(quote math-break) (list body)))
  2301.       body))
  2302. )
  2303.  
  2304.  
  2305. (defun math-handle-foreach (head body)
  2306.   (let ((var (nth 0 (car head)))
  2307.     (data (nth 1 (car head)))
  2308.     (body (if (cdr head)
  2309.           (list (math-handle-foreach (cdr head) body))
  2310.         body)))
  2311.     (cons 'let
  2312.       (cons (list (list var data))
  2313.         (list
  2314.          (cons 'while
  2315.                (cons var
  2316.                  (append body
  2317.                      (list (list 'setq
  2318.                          var
  2319.                          (list 'cdr var))))))))))
  2320. )
  2321.  
  2322.  
  2323. (defun math-body-refers-to (body thing)
  2324.   (or (equal body thing)
  2325.       (and (consp body)
  2326.        (or (math-body-refers-to (car body) thing)
  2327.            (math-body-refers-to (cdr body) thing))))
  2328. )
  2329.  
  2330. (defun math-break (&optional value)
  2331.   (throw 'math-break value)
  2332. )
  2333.  
  2334. (defun math-return (&optional value)
  2335.   (throw 'math-return value)
  2336. )
  2337.  
  2338.  
  2339.  
  2340.  
  2341.  
  2342. (defun math-composite-inequalities (x op)
  2343.   (if (memq (nth 1 op) '(calcFunc-eq calcFunc-neq))
  2344.       (if (eq (car x) (nth 1 op))
  2345.       (append x (list (math-read-expr-level (nth 3 op))))
  2346.     (throw 'syntax "Syntax error"))
  2347.     (list 'calcFunc-in
  2348.       (nth 2 x)
  2349.       (if (memq (nth 1 op) '(calcFunc-lt calcFunc-leq))
  2350.           (if (memq (car x) '(calcFunc-lt calcFunc-leq))
  2351.           (math-make-intv
  2352.            (+ (if (eq (car x) 'calcFunc-leq) 2 0)
  2353.               (if (eq (nth 1 op) 'calcFunc-leq) 1 0))
  2354.            (nth 1 x) (math-read-expr-level (nth 3 op)))
  2355.         (throw 'syntax "Syntax error"))
  2356.         (if (memq (car x) '(calcFunc-gt calcFunc-geq))
  2357.         (math-make-intv
  2358.          (+ (if (eq (nth 1 op) 'calcFunc-geq) 2 0)
  2359.             (if (eq (car x) 'calcFunc-geq) 1 0))
  2360.          (math-read-expr-level (nth 3 op)) (nth 1 x))
  2361.           (throw 'syntax "Syntax error")))))
  2362. )
  2363.  
  2364.